Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue50/HTML/mleTagResolvers.pas

Pascal/Delphi Source File | 1999-08-08 | 7.7 KB | 329 lines

unit mleTagResolvers;

interface

uses
  Classes, DBTables, dpoBase, usXMLDoc;

type
  TControlType = (ctUnknown, ctEditBox, ctCheckBox, ctSelect, ctTable);

const
  CONTROL_TYPE_NAMES: array[TControlType] of string =
    ('', 'edit', 'checkbox', 'select', 'table');

type
  TTagResolver = class;
  TTagResolverClass = class of TTagResolver;

  TTagResolver = class
  private
    FParent: TTagResolver;
    FTagElement: TusXMLElement;
  protected
    HTML: TStringList;

    { Functional methods }
    procedure GetAttributes; virtual;
    procedure GetSubtags;
    procedure HandleSubtag(aElement: TusXMLElement; var aHandled: Boolean); virtual;

    { Helper methods }
    function GetAttribute(aName, aDefault: string): string;
  public
    constructor Create(aParent: TTagResolver; aTagElement: TusXMLElement);
    destructor Destroy; override;
    function GetHTML: string; virtual;
    procedure Resolve; virtual;
    procedure Setup; virtual;
  end;

  TSimpleControlTagResolver = class(TTagResolver)
  protected
    AType: string;
    AName: string;
    AValue: string;
    procedure GetAttributes; override;
  public
    procedure Resolve; override;
  end;

  TSMLTagResolver = class(TTagResolver)
  protected
    procedure HandleSubtag(aElement: TusXMLElement; var aHandled: Boolean); override;
  end;

  TDataObjectTagResolver = class(TTagResolver)
  protected
    AClassName: string;
    AName: string;
    AOID: string;
    AClass: TDataObjectClass;
    procedure GetAttributes; override;
  public
    procedure Resolve; override;
  end;

  TControlTagResolver = class(TTagResolver)
  protected
    AType: string;
    AName: string;
    APropertyName: string;
    AValue: string;
    XType: TControlType;
    procedure GetAttributes; override;
    function GetPropertyValue(aPropertyReference: string): string;
  public
    procedure Resolve; override;
  end;

  TObjectCache = class(TStringList)
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear; override;
    function GetPropertyValue(aPropertyName: string): string;
  end;

var
  MLEDatabase: TDatabase;
  ObjectCache: TObjectCache;

implementation

uses
  SysUtils;

{ TObjectCache }

procedure TObjectCache.Clear;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    TDataObject(Objects[I]).Free;
  inherited Clear;
end;

constructor TObjectCache.Create;
begin
  inherited;
  Sorted := True;
  Duplicates := dupError;
end;

destructor TObjectCache.Destroy;
begin
  Clear;
  inherited;
end;

function TObjectCache.GetPropertyValue(aPropertyName: string): string;
var
  ObjectName: string;
  PropertyName: string;
  I: Integer;
begin
  I := Pos('.', aPropertyName);
  ObjectName := Copy(aPropertyName, 1, I - 1);
  PropertyName := Copy(aPropertyName, I + 1, Length(aPropertyName) - I);
  I := IndexOf(ObjectName);
  if I = -1 then
    raise Exception.CreateFmt('Invalid object name: "%s"', [ObjectName]);
  Result := TDataObject(Objects[I]).PropertyByName(PropertyName).AsString;
end;

{ TTagResolver }

constructor TTagResolver.Create(aParent: TTagResolver; aTagElement: TusXMLElement);
begin
  inherited Create;
  FParent := aParent;
  FTagElement := aTagElement;
  HTML := TStringList.Create;
end;

destructor TTagResolver.Destroy;
begin
  HTML.Free;
  inherited;
end;

function TTagResolver.GetAttribute(aName, aDefault: string): string;
var
  Attr: TusXMLAttribute;
begin
  Result := aDefault;
  Attr := FTagElement.Attributes.GetByName(aName);
  if Assigned(Attr) then
    Result := Attr.Value;
end;

procedure TTagResolver.GetAttributes;
begin
  // do nothing; not all tags will have attributes
end;

function TTagResolver.GetHTML: string;
begin
  Result := '';
  if HTML.Count <> 0 then
    Result := HTML.Text;
end;

procedure TTagResolver.GetSubtags;
var
  I: Integer;
  Handled: Boolean;
begin
  for I := 0 to FTagElement.Subtags.Count - 1 do
  begin
    Handled := False;
    HandleSubtag(FTagElement.Subtags[I], Handled);
    if not Handled then
      raise Exception.CreateFmt('Unexpected subtag <%s>', [FTagElement.Subtags[I].TagName]);
  end;
end;

procedure TTagResolver.HandleSubtag(aElement: TusXMLElement;
  var aHandled: Boolean);
begin
  // Do nothing; not all tags will have subtags
end;

procedure TTagResolver.Resolve;
begin
  // Do nothing; logic is tag-specific
end;

procedure TTagResolver.Setup;
begin
  GetAttributes;
  GetSubtags;
end;

{ TSMLTagResolver }

procedure TSMLTagResolver.HandleSubtag(aElement: TusXMLElement;
  var aHandled: Boolean);
const
  NUM_ENTRIES = 2;
  TagTable: array[0..NUM_ENTRIES - 1] of record
    TagName: string;
    ResolverClass: TTagResolverClass;
  end = ((TagName:'CONTROL'; ResolverClass:TControlTagResolver),
         (TagName:'DATAOBJECT'; ResolverClass:TDataObjectTagResolver)
         );
var
  I: Integer;
  S: string;
begin
  for I := 0 to NUM_ENTRIES - 1 do
    with TagTable[I] do
      if aElement.TagName = TagName then
      begin
        with ResolverClass.Create(Self, aElement) do
          try
            Setup;
            Resolve;
            S := GetHTML;
            if S <> '' then
              Self.HTML.Add(S);
          finally
            Free;
          end;
        aHandled := True;
        Break;
      end;
end;

{ TControlTagResolver }

procedure TControlTagResolver.GetAttributes;
begin
  inherited;
  AType := GetAttribute('type', '');
  AName := GetAttribute('name', '');
  APropertyName := GetAttribute('property', '');
  AValue := GetAttribute('value', '');
end;

function TControlTagResolver.GetPropertyValue(aPropertyReference: string): string;
var
  ObjectName: string;
  PropertyName: string;
  I: Integer;
begin
  I := Pos('.', aPropertyName);
  ObjectName := Copy(aPropertyName, 1, I - 1);
  PropertyName := Copy(aPropertyName, I + 1, Length(aPropertyName) - I);
  I := ObjectCache.IndexOf(ObjectName);
  if I = -1 then
    raise Exception.CreateFmt('Invalid object name: "%s"', [ObjectName]);
  Result := TDataObject(ObjectCache.Objects[I]).PropertyByName(PropertyName).AsString;
end;

procedure TControlTagResolver.Resolve;
begin
  if APropertyName <> '' then
    AValue :=  GetPropertyValue(APropertyName);

  if AType = 'edit' then
  begin
    HTML.Add(Format('<INPUT type="text" name="%s" value="%s">',
                    [AName, aValue]));
  end;
end;

{ TSimpleControlTagResolver }

procedure TSimpleControlTagResolver.GetAttributes;
begin
  AType := GetAttribute('type', '');
  if AType <> 'edit' then
    raise Exception.CreateFmt('Illegal value for "type" attribute: %s', [AType]);
  AName := GetAttribute('name', '');
  AValue := GetAttribute('value', '');
end;

procedure TSimpleControlTagResolver.Resolve;
begin
  if AType = 'edit' then
  begin
    HTML.Add(Format('<INPUT type="text" name="%s" value="%s">',
                    [AName, aValue]));
  end;
end;

{ TDataObjectTagResolver }

procedure TDataObjectTagResolver.GetAttributes;
var
  TempClass: TPersistentClass;
begin
  AClassName := GetAttribute('class', '');
  AName := GetAttribute('name', '');
  AOID := GetAttribute('oid', '');

  TempClass := GetClass(AClassName);
  if not (Assigned(TempClass) or TempClass.InheritsFrom(TDataObject)) then
    raise Exception.CreateFmt('%s is not a valid class', [AClassName]);
  AClass := TDataObjectClass(TempClass);
end;

procedure TDataObjectTagResolver.Resolve;
var
  Instance: TDataObject;
begin
  Instance := AClass.Create(MLEDatabase);
  ObjectCache.AddObject(AName, Instance);
  if AOID <> '' then
    Instance.GetByOID(AOID);
end;

initialization
  ObjectCache := TObjectCache.Create;
finalization
  ObjectCache.Free;
end.